home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / glyphs.el.z / glyphs.el
Encoding:
Text File  |  1998-05-21  |  28.6 KB  |  680 lines
  1. ;;; glyphs.el --- Lisp interface to C glyphs
  2.  
  3. ;; Copyright (C) 1994, 1997 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1995, 1996 Ben Wing.
  5.  
  6. ;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>, Ben Wing <wing@666.com>
  7. ;; Maintainer: XEmacs Development Team
  8. ;; Keywords: extensions, internal
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  24. ;; Free Software Foundation, 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Synched up with: Not in FSF.
  28.  
  29. ;;; Commentary:
  30.  
  31. ;;; Code:
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font specifiers
  34.  
  35. (defun make-image-specifier (spec-list)
  36.   "Create a new `image' specifier object with the given specification list.
  37. SPEC-LIST can be a list of specifications (each of which is a cons of a
  38. locale and a list of instantiators), a single instantiator, or a list
  39. of instantiators.  See `make-specifier' for more information about
  40. specifiers."
  41.   (make-specifier-and-init 'image spec-list))
  42.  
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; glyphs
  44.  
  45. (defconst built-in-glyph-specifiers
  46.   '(image contrib-p baseline)
  47.   "A list of the built-in face properties that are specifiers.")
  48.  
  49. (defun glyph-property (glyph property &optional locale)
  50.   "Return GLYPH's value of the given PROPERTY.
  51.  
  52. If LOCALE is omitted, the GLYPH's actual value for PROPERTY will be
  53.   returned.  For built-in properties, this will be a specifier object
  54.   of a type appropriate to the property (e.g. a font or color
  55.   specifier).  For other properties, this could be anything.
  56.  
  57. If LOCALE is supplied, then instead of returning the actual value,
  58.   the specification(s) for the given locale or locale type will
  59.   be returned.  This will only work if the actual value of
  60.   PROPERTY is a specifier (this will always be the case for built-in
  61.   properties, but not or not may apply to user-defined properties).
  62.   If the actual value of PROPERTY is not a specifier, this value
  63.   will simply be returned regardless of LOCALE.
  64.  
  65. The return value will be a list of instantiators (e.g. strings
  66.   specifying a font or color name), or a list of specifications, each
  67.   of which is a cons of a locale and a list of instantiators.
  68.   Specifically, if LOCALE is a particular locale (a buffer, window,
  69.   frame, device, or 'global), a list of instantiators for that locale
  70.   will be returned.  Otherwise, if LOCALE is a locale type (one of
  71.   the symbols 'buffer, 'window, 'frame, 'device, 'device-class, or
  72.   'device-type), the specifications for all locales of that type will
  73.   be returned.  Finally, if LOCALE is 'all, the specifications for all
  74.   locales of all types will be returned.
  75.  
  76. The specifications in a specifier determine what the value of
  77.   PROPERTY will be in a particular \"domain\" or set of circumstances,
  78.   which is typically a particular Emacs window along with the buffer
  79.   it contains and the frame and device it lies within.  The value
  80.   is derived from the instantiator associated with the most specific
  81.   locale (in the order buffer, window, frame, device, and 'global)
  82.   that matches the domain in question.  In other words, given a domain
  83.   (i.e. an Emacs window, usually), the specifier for PROPERTY will first
  84.   be searched for a specification whose locale is the buffer contained
  85.   within that window; then for a specification whose locale is the window
  86.   itself; then for a specification whose locale is the frame that the
  87.   window is contained within; etc.  The first instantiator that is
  88.   valid for the domain (usually this means that the instantiator is
  89.   recognized by the device [i.e. the X server or TTY device] that the
  90.   domain is on.  The function `glyph-property-instance' actually does
  91.   all this, and is used to determine how to display the glyph.
  92.  
  93. See `set-glyph-property' for the built-in property-names."
  94.   (check-argument-type 'glyphp glyph)
  95.   (let ((value (get glyph property)))
  96.     (if (and locale
  97.          (or (memq property built-in-glyph-specifiers)
  98.          (specifierp value)))
  99.     (setq value (specifier-specs value locale)))
  100.     value))
  101.  
  102. (defun convert-glyph-property-into-specifier (glyph property)
  103.   "Convert PROPERTY on GLYPH into a specifier, if it's not already."
  104.   (check-argument-type 'glyphp glyph)
  105.   (let ((specifier (get glyph property)))
  106.     ;; if a user-property does not have a specifier but a
  107.     ;; locale was specified, put a specifier there.  
  108.     ;; If there was already a value there, convert it to a
  109.     ;; specifier with the value as its 'global instantiator.
  110.     (if (not (specifierp specifier))
  111.     (let ((new-specifier (make-specifier 'generic)))
  112.       (if (or (not (null specifier))
  113.           ;; make sure the nil returned from `get' wasn't
  114.           ;; actually the value of the property
  115.           (null (get glyph property t)))
  116.           (add-spec-to-specifier new-specifier specifier))
  117.       (setq specifier new-specifier)
  118.       (put glyph property specifier)))))
  119.  
  120. (defun glyph-property-instance (glyph property
  121.                       &optional domain default no-fallback)
  122.   "Return the instance of GLYPH's PROPERTY in the specified DOMAIN.
  123.  
  124. Under most circumstances, DOMAIN will be a particular window,
  125.   and the returned instance describes how the specified property
  126.   actually is displayed for that window and the particular buffer
  127.   in it.  Note that this may not be the same as how the property
  128.   appears when the buffer is displayed in a different window or
  129.   frame, or how the property appears in the same window if you
  130.   switch to another buffer in that window; and in those cases,
  131.   the returned instance would be different.
  132.  
  133. DOMAIN defaults to the selected window if omitted.
  134.  
  135. DOMAIN can be a frame or device, instead of a window.  The value
  136.   returned for a such a domain is used in special circumstances
  137.   when a more specific domain does not apply; for example, a frame
  138.   value might be used for coloring a toolbar, which is conceptually
  139.   attached to a frame rather than a particular window.  The value
  140.   is also useful in determining what the value would be for a
  141.   particular window within the frame or device, if it is not
  142.   overridden by a more specific specification.
  143.  
  144. If PROPERTY does not name a built-in property, its value will
  145.   simply be returned unless it is a specifier object, in which case
  146.   it will be instanced using `specifier-instance'.
  147.  
  148. Optional arguments DEFAULT and NO-FALLBACK are the same as in
  149.   `specifier-instance'."
  150.   (check-argument-type 'glyphp glyph)
  151.   (let ((value (get glyph property)))
  152.     (if (specifierp value)
  153.     (setq value (specifier-instance value domain default no-fallback)))
  154.     value))
  155.  
  156. (defun set-glyph-property (glyph property value &optional locale tag-set
  157.                  how-to-add)
  158.   "Change a property of a GLYPH.
  159.  
  160. NOTE: If you want to remove a property from a glyph, use
  161.   `remove-glyph-property' rather than attempting to set a value of nil
  162.    for the property.
  163.  
  164. For built-in properties, the actual value of the property is a
  165.   specifier and you cannot change this; but you can change the
  166.   specifications within the specifier, and that is what this function
  167.   will do.  For user-defined properties, you can use this function
  168.   to either change the actual value of the property or, if this value
  169.   is a specifier, change the specifications within it.
  170.  
  171. If PROPERTY is a built-in property, the specifications to be added to
  172.   this property can be supplied in many different ways:
  173.  
  174.   -- If VALUE is a simple instantiator (e.g. a string naming a font or
  175.      color) or a list of instantiators, then the instantiator(s) will
  176.      be added as a specification of the property for the given LOCALE
  177.      (which defaults to 'global if omitted).
  178.   -- If VALUE is a list of specifications (each of which is a cons of
  179.      a locale and a list of instantiators), then LOCALE must be nil
  180.      (it does not make sense to explicitly specify a locale in this
  181.      case), and specifications will be added as given.
  182.   -- If VALUE is a specifier (as would be returned by `glyph-property'
  183.      if no LOCALE argument is given), then some or all of the
  184.      specifications in the specifier will be added to the property.
  185.      In this case, the function is really equivalent to
  186.      `copy-specifier' and LOCALE has the same semantics (if it is
  187.      a particular locale, the specification for the locale will be
  188.      copied; if a locale type, specifications for all locales of
  189.      that type will be copied; if nil or 'all, then all
  190.      specifications will be copied).
  191.  
  192. HOW-TO-ADD should be either nil or one of the symbols 'prepend,
  193.   'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale,
  194.   'remove-locale-type, or 'remove-all.  See `copy-specifier' and
  195.   `add-spec-to-specifier' for a description of what each of
  196.   these means.  Most of the time, you do not need to worry about
  197.   this argument; the default behavior usually is fine.
  198.  
  199. In general, it is OK to pass an instance object (e.g. as returned
  200.   by `glyph-property-instance') as an instantiator in place of
  201.   an actual instantiator.  In such a case, the instantiator used
  202.   to create that instance object will be used (for example, if
  203.   you set a font-instance object as the value of the 'font
  204.   property, then the font name used to create that object will
  205.   be used instead).  If some cases, however, doing this
  206.   conversion does not make sense, and this will be noted in
  207.   the documentation for particular types of instance objects.
  208.  
  209. If PROPERTY is not a built-in property, then this function will
  210.   simply set its value if LOCALE is nil.  However, if LOCALE is
  211.   given, then this function will attempt to add VALUE as the
  212.   instantiator for the given LOCALE, using `add-spec-to-specifier'.
  213.   If the value of the property is not a specifier, it will
  214.   automatically be converted into a 'generic specifier.
  215.  
  216.  
  217. The following symbols have predefined meanings:
  218.  
  219.  image            The image used to display the glyph.
  220.  
  221.  baseline        Percent above baseline that glyph is to be
  222.             displayed.
  223.  
  224.  contrib-p        Whether the glyph contributes to the
  225.             height of the line it's on.
  226.  
  227.  face            Face of this glyph (*not* a specifier)."
  228.   (check-argument-type 'glyphp glyph)
  229.   (if (memq property built-in-glyph-specifiers)
  230.       (set-specifier (get glyph property) value locale tag-set how-to-add)
  231.  
  232.     ;; This section adds user defined properties.
  233.     (if (not locale)
  234.     (put glyph property value)
  235.       (convert-glyph-property-into-specifier glyph property)
  236.       (add-spec-to-specifier (get glyph property) value locale tag-set
  237.                  how-to-add)))
  238.   value)
  239.  
  240. (defun remove-glyph-property (glyph property &optional locale tag-set exact-p)
  241.   "Remove a property from a glyph.
  242. For built-in properties, this is analogous to `remove-specifier'.
  243. See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P
  244.   arguments."
  245.   (or locale (setq locale 'all))
  246.   (if (memq property built-in-glyph-specifiers)
  247.       (remove-specifier (glyph-property glyph property) locale tag-set exact-p)
  248.     (if (eq locale 'all)
  249.     (remprop glyph property)
  250.       (convert-glyph-property-into-specifier glyph property)
  251.       (remove-specifier (glyph-property glyph property) locale tag-set
  252.             exact-p))))
  253.  
  254. (defun glyph-face (glyph)
  255.   "Return the face of GLYPH."
  256.   (glyph-property glyph 'face))
  257.  
  258. (defun set-glyph-face (glyph face)
  259.   "Change the face of GLYPH to FACE."
  260. ;  (interactive (glyph-interactive "face"))
  261.   (set-glyph-property glyph 'face face))
  262.  
  263. (defun glyph-image (glyph &optional locale)
  264.   "Return the image of the given glyph, or nil if it is unspecified.
  265.  
  266. LOCALE may be a locale (the instantiators for that particular locale
  267.   will be returned), a locale type (the specifications for all locales
  268.   of that type will be returned), 'all (all specifications will be
  269.   returned), or nil (the actual specifier object will be returned).
  270.  
  271. See `glyph-property' for more information."
  272.   (glyph-property glyph 'image locale))
  273.  
  274. (defun glyph-image-instance (glyph &optional domain default no-fallback)
  275.   "Return the instance of the given glyph's image in the given domain.
  276.  
  277. Normally DOMAIN will be a window or nil (meaning the selected window),
  278.   and an instance object describing how the image appears in that
  279.   particular window and buffer will be returned.
  280.  
  281. See `glyph-property-instance' for more information."
  282.   (glyph-property-instance glyph 'image domain default no-fallback))
  283.  
  284. (defun set-glyph-image (glyph spec &optional locale tag-set how-to-add)
  285.   "Change the image of the given glyph.
  286.  
  287. SPEC should be an instantiator (a string or vector; see
  288.   `image-specifier-p' for a description of possible values here),
  289.   a list of (possibly tagged) instantiators, an alist of specifications
  290.   (each mapping a locale to an instantiator list), or an image specifier
  291.   object.
  292.  
  293. If SPEC is an alist, LOCALE must be omitted.  If SPEC is a
  294.   specifier object, LOCALE can be a locale, a locale type, 'all,
  295.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  296.   specifies the locale under which the specified instantiator(s)
  297.   will be added, and defaults to 'global.
  298.  
  299. See `set-glyph-property' for more information."
  300.   ; (interactive (glyph-interactive "image"))
  301.   (set-glyph-property glyph 'image spec locale tag-set how-to-add))
  302.  
  303. (defun glyph-contrib-p (glyph &optional locale)
  304.   "Return whether GLYPH contributes to its line height.
  305.  
  306. LOCALE may be a locale (the instantiators for that particular locale
  307.   will be returned), a locale type (the specifications for all locales
  308.   of that type will be returned), 'all (all specifications will be
  309.   returned), or nil (the actual specifier object will be returned).
  310.  
  311. See `glyph-property' for more information."
  312.   (glyph-property glyph 'contrib-p locale))
  313.  
  314. (defun glyph-contrib-p-instance (glyph &optional domain default no-fallback)
  315.   "Return the instance of the GLYPH's 'contrib-p property in the given domain.
  316.  
  317. Normally DOMAIN will be a window or nil (meaning the selected window),
  318.   and an instance object describing what the 'contrib-p property is in
  319.   that particular window and buffer will be returned.
  320.  
  321. See `glyph-property-instance' for more information."
  322.   (glyph-property-instance glyph 'contrib-p domain default no-fallback))
  323.  
  324. (defun set-glyph-contrib-p (glyph spec &optional locale tag-set how-to-add)
  325.   "Change the contrib-p of the given glyph.
  326.  
  327. SPEC should be an instantiator (t or nil), a list of (possibly
  328.   tagged) instantiators, an alist of specifications (each mapping a
  329.   locale to an instantiator list), or a boolean specifier object.
  330.  
  331. If SPEC is an alist, LOCALE must be omitted.  If SPEC is a
  332.   specifier object, LOCALE can be a locale, a locale type, 'all,
  333.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  334.   specifies the locale under which the specified instantiator(s)
  335.   will be added, and defaults to 'global.
  336.  
  337. See `set-glyph-property' for more information."
  338.   ; (interactive (glyph-interactive "contrib-p"))
  339.   (set-glyph-property glyph 'contrib-p spec locale tag-set how-to-add))
  340.  
  341. (defun glyph-baseline (glyph &optional locale)
  342.   "Return the baseline of the given glyph, or nil if it is unspecified.
  343.  
  344. LOCALE may be a locale (the instantiators for that particular locale
  345.   will be returned), a locale type (the specifications for all locales
  346.   of that type will be returned), 'all (all specifications will be
  347.   returned), or nil (the actual specifier object will be returned).
  348.  
  349. See `glyph-property' for more information."
  350.   (glyph-property glyph 'baseline locale))
  351.  
  352. (defun glyph-baseline-instance (glyph &optional domain default no-fallback)
  353.   "Return the instance of the given glyph's baseline in the given domain.
  354.  
  355. Normally DOMAIN will be a window or nil (meaning the selected window),
  356.   and an integer or nil (specifying the baseline in that particular
  357.   window and buffer) will be returned.
  358.  
  359. See `glyph-property-instance' for more information."
  360.   (glyph-property-instance glyph 'baseline domain default no-fallback))
  361.  
  362. (defun set-glyph-baseline (glyph spec &optional locale tag-set how-to-add)
  363.   "Change the baseline of the given glyph.
  364.  
  365. SPEC should be an instantiator (an integer [a percentage above the
  366.   baseline of the line the glyph is on] or nil), a list of (possibly
  367.   tagged) instantiators, an alist of specifications (each mapping a
  368.   locale to an instantiator list), or a generic specifier object.
  369.  
  370. If SPEC is an alist, LOCALE must be omitted.  If SPEC is a
  371.   specifier object, LOCALE can be a locale, a locale type, 'all,
  372.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  373.   specifies the locale under which the specified instantiator(s)
  374.   will be added, and defaults to 'global.
  375.  
  376. See `set-glyph-property' for more information."
  377.   ; (interactive (glyph-interactive "baseline"))
  378.   (set-glyph-property glyph 'baseline spec locale tag-set how-to-add))
  379.  
  380. (defun make-glyph (&optional spec-list type)
  381.   "Create a new `glyph' object of type TYPE.
  382.  
  383. TYPE should be one of `buffer' (used for glyphs in an extent, the modeline,
  384. the toolbar, or elsewhere in a buffer), `pointer' (used for the mouse-pointer),
  385. or `icon' (used for a frame's icon), and defaults to `buffer'.
  386.  
  387. SPEC-LIST is used to initialize the glyph's image.  It is typically an
  388. image instantiator (a string or a vector; see `image-specifier-p' for
  389. a detailed description of the valid image instantiators), but can also
  390. be a list of such instantiators (each one in turn is tried until an
  391. image is successfully produced), a cons of a locale (frame, buffer, etc.)
  392. and an instantiator, a list of such conses, or any other form accepted
  393. by `canonicalize-spec-list'.  See `make-specifier' for more information
  394. about specifiers."
  395.   (let ((glyph (make-glyph-internal type)))
  396.     (and spec-list (set-glyph-image glyph spec-list))
  397.     glyph))
  398.  
  399. (defun buffer-glyph-p (object)
  400.   "t if OBJECT is a glyph of type `buffer'."
  401.   (and (glyphp object) (eq 'buffer (glyph-type object))))
  402.  
  403. (defun pointer-glyph-p (object)
  404.   "t if OBJECT is a glyph of type `pointer'."
  405.   (and (glyphp object) (eq 'pointer (glyph-type object))))
  406.  
  407. (defun icon-glyph-p (object)
  408.   "t if OBJECT is a glyph of type `icon'."
  409.   (and (glyphp object) (eq 'icon (glyph-type object))))
  410.  
  411. (defun make-pointer-glyph (&optional spec-list)
  412.   "Create a new `pointer-glyph' object with the given specification list.
  413.  
  414. This is equivalent to calling `make-glyph' and specifying a type of
  415. `pointer'.
  416.  
  417. SPEC-LIST is used to initialize the glyph's image.  It is typically an
  418. image instantiator (a string or a vector; see `image-specifier-p' for
  419. a detailed description of the valid image instantiators), but can also
  420. be a list of such instantiators (each one in turn is tried until an
  421. image is successfully produced), a cons of a locale (frame, buffer, etc.)
  422. and an instantiator, a list of such conses, or any other form accepted
  423. by `canonicalize-spec-list'.  See `make-specifier' for more information
  424. about specifiers.
  425.  
  426. You can also create a glyph with an empty SPEC-LIST and add image
  427. instantiators afterwards using `set-glyph-image'."
  428.   (make-glyph spec-list 'pointer))
  429.  
  430. (defun make-icon-glyph (&optional spec-list)
  431.   "Create a new `icon-glyph' object with the given specification list.
  432.  
  433. This is equivalent to calling `make-glyph' and specifying a type of
  434. `icon'.
  435.  
  436. SPEC-LIST is used to initialize the glyph's image.  It is typically an
  437. image instantiator (a string or a vector; see `image-specifier-p' for
  438. a detailed description of the valid image instantiators), but can also
  439. be a list of such instantiators (each one in turn is tried until an
  440. image is successfully produced), a cons of a locale (frame, buffer, etc.)
  441. and an instantiator, a list of such conses, or any other form accepted
  442. by `canonicalize-spec-list'.  See `make-specifier' for more information
  443. about specifiers.
  444.  
  445. You can also create a glyph with an empty SPEC-LIST and add image
  446. instantiators afterwards using `set-glyph-image'."
  447.   (make-glyph spec-list 'icon))
  448.  
  449. (defun nothing-image-instance-p (object)
  450.   "t if OBJECT is an image instance of type `nothing'."
  451.   (and (image-instance-p object) (eq 'nothing (image-instance-type object))))
  452.  
  453. (defun text-image-instance-p (object)
  454.   "t if OBJECT is an image instance of type `text'."
  455.   (and (image-instance-p object) (eq 'text (image-instance-type object))))
  456.  
  457. (defun mono-pixmap-image-instance-p (object)
  458.   "t if OBJECT is an image instance of type `mono-pixmap'."
  459.   (and (image-instance-p object) (eq 'mono-pixmap
  460.                      (image-instance-type object))))
  461.  
  462. (defun color-pixmap-image-instance-p (object)
  463.   "t if OBJECT is an image instance of type `color-pixmap'."
  464.   (and (image-instance-p object) (eq 'color-pixmap
  465.                      (image-instance-type object))))
  466.  
  467. (defun pointer-image-instance-p (object)
  468.   "t if OBJECT is an image instance of type `pointer'."
  469.   (and (image-instance-p object) (eq 'pointer (image-instance-type object))))
  470.  
  471. (defun subwindow-image-instance-p (object)
  472.   "t if OBJECT is an image instance of type `subwindow'.
  473. Subwindows are not implemented in this version of XEmacs."
  474.   (and (image-instance-p object) (eq 'subwindow (image-instance-type object))))
  475.  
  476. ;;;;;;;;;; the built-in glyphs
  477.  
  478. (defvar text-pointer-glyph (make-pointer-glyph)
  479.   "*The shape of the mouse-pointer when over text.
  480. This is a glyph; use `set-glyph-image' to change it.")
  481. (set-glyph-face text-pointer-glyph 'pointer)
  482.  
  483. (defvar nontext-pointer-glyph (make-pointer-glyph)
  484.   "*The shape of the mouse-pointer when over a buffer, but not over text.
  485. This is a glyph; use `set-glyph-image' to change it.
  486. If unspecified in a particular domain, `text-pointer-glyph' is used.")
  487. (set-glyph-face nontext-pointer-glyph 'pointer)
  488.  
  489. (defvar modeline-pointer-glyph (make-pointer-glyph)
  490.   "*The shape of the mouse-pointer when over the modeline.
  491. This is a glyph; use `set-glyph-image' to change it.
  492. If unspecified in a particular domain, `nontext-pointer-glyph' is used.")
  493. (set-glyph-face modeline-pointer-glyph 'pointer)
  494.  
  495. (defvar selection-pointer-glyph (make-pointer-glyph)
  496.   "*The shape of the mouse-pointer when over a selectable text region.
  497. This is a glyph; use `set-glyph-image' to change it.
  498. If unspecified in a particular domain, `text-pointer-glyph' is used.")
  499. (set-glyph-face selection-pointer-glyph 'pointer)
  500.  
  501. (defvar busy-pointer-glyph (make-pointer-glyph)
  502.   "*The shape of the mouse-pointer when XEmacs is busy.
  503. This is a glyph; use `set-glyph-image' to change it.
  504. If unspecified in a particular domain, the pointer is not changed
  505. when XEmacs is busy.")
  506. (set-glyph-face busy-pointer-glyph 'pointer)
  507.  
  508. (defvar toolbar-pointer-glyph (make-pointer-glyph)
  509.   "*The shape of the mouse-pointer when over a toolbar.
  510. This is a glyph; use `set-glyph-image' to change it.
  511. If unspecified in a particular domain, `nontext-pointer-glyph' is used.")
  512. (set-glyph-face toolbar-pointer-glyph 'pointer)
  513.  
  514. ;; The following three are in C.
  515. (if (featurep 'menubar)
  516.     (set-glyph-face menubar-pointer-glyph 'pointer))
  517. (if (featurep 'scrollbar)
  518.     (set-glyph-face scrollbar-pointer-glyph 'pointer))
  519. (set-glyph-face gc-pointer-glyph 'pointer)
  520.  
  521. ;; Now add the magic access/set behavior.
  522.  
  523. (defun dontusethis-set-value-glyph-handler (sym args fun harg handler)
  524.   (error "Use `set-glyph-image' to set `%s'" sym))
  525. (defun dontusethis-make-unbound-glyph-handler (sym args fun harg handler)
  526.   (error "Can't `makunbound' `%s'" sym))
  527. (defun dontusethis-make-local-glyph-handler (sym args fun harg handler)
  528.   (error "Use `set-glyph-image' to make local values for `%s'" sym))
  529.  
  530. (defun define-constant-glyph (sym)
  531.   (dontusethis-set-symbol-value-handler
  532.    sym 'set-value
  533.    'dontusethis-set-value-glyph-handler)
  534.   (dontusethis-set-symbol-value-handler
  535.    sym 'make-unbound
  536.    'dontusethis-make-unbound-glyph-handler)
  537.   (dontusethis-set-symbol-value-handler
  538.    sym 'make-local
  539.    'dontusethis-make-local-glyph-handler)
  540.   ;; Make frame properties magically work with glyph variables.
  541.   (put sym 'const-glyph-variable t))
  542.  
  543. (define-constant-glyph 'text-pointer-glyph)
  544. (define-constant-glyph 'nontext-pointer-glyph)
  545. (define-constant-glyph 'modeline-pointer-glyph)
  546. (define-constant-glyph 'selection-pointer-glyph)
  547. (define-constant-glyph 'busy-pointer-glyph)
  548. (define-constant-glyph 'gc-pointer-glyph)
  549. (define-constant-glyph 'toolbar-pointer-glyph)
  550. (define-constant-glyph 'menubar-pointer-glyph)
  551. (define-constant-glyph 'scrollbar-pointer-glyph)
  552.  
  553. (define-constant-glyph 'octal-escape-glyph)
  554. (define-constant-glyph 'control-arrow-glyph)
  555. (define-constant-glyph 'invisible-text-glyph)
  556. (define-constant-glyph 'hscroll-glyph)
  557. (define-constant-glyph 'truncation-glyph)
  558. (define-constant-glyph 'continuation-glyph)
  559.  
  560. (define-constant-glyph 'frame-icon-glyph)
  561.  
  562. ;; backwards compatibility garbage
  563.  
  564. (defun dontusethis-old-pointer-shape-handler (sym args fun harg handler)
  565.   (let ((value (car args)))
  566.     (if (null value)
  567.     (remove-specifier harg 'global)
  568.       (set-glyph-image (symbol-value harg) value))))
  569.  
  570. ;; It might or might not be garbage, but it's rude.  Make these
  571. ;; 'compatible instead of 'obsolete.  -slb
  572. (defun define-obsolete-pointer-glyph (old new)
  573.   (define-compatible-variable-alias old new)
  574.   (dontusethis-set-symbol-value-handler
  575.    old 'set-value 'dontusethis-old-pointer-shape-handler new))
  576.  
  577. ;;; (defvar x-pointer-shape nil)
  578. (define-obsolete-pointer-glyph 'x-pointer-shape 'text-pointer-glyph)
  579.  
  580. ;;; (defvar x-nontext-pointer-shape nil)
  581. (define-obsolete-pointer-glyph 'x-nontext-pointer-shape 'nontext-pointer-glyph)
  582.  
  583. ;;; (defvar x-mode-pointer-shape nil)
  584. (define-obsolete-pointer-glyph 'x-mode-pointer-shape 'modeline-pointer-glyph)
  585.  
  586. ;;; (defvar x-selection-pointer-shape nil)
  587. (define-obsolete-pointer-glyph 'x-selection-pointer-shape
  588.   'selection-pointer-glyph)
  589.  
  590. ;;; (defvar x-busy-pointer-shape nil)
  591. (define-obsolete-pointer-glyph 'x-busy-pointer-shape 'busy-pointer-glyph)
  592.  
  593. ;;; (defvar x-gc-pointer-shape nil)
  594. (define-obsolete-pointer-glyph 'x-gc-pointer-shape 'gc-pointer-glyph)
  595.  
  596. ;;; (defvar x-toolbar-pointer-shape nil)
  597. (define-obsolete-pointer-glyph 'x-toolbar-pointer-shape 'toolbar-pointer-glyph)
  598.  
  599. ;;;;;;;;;; initialization
  600.  
  601. (defun init-glyphs ()
  602.   ;; initialize default image types
  603.   (if (featurep 'x)
  604.     (set-console-type-image-conversion-list 'x
  605.      `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2)))
  606.      ("\\.xbm\\'" [xbm :file nil] 2)
  607.        ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2)))
  608.        ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2)))
  609.        ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2)
  610.                    ("\\`GIF8[79]" [gif :data nil] 2)))
  611.        ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2)))
  612.        ;; all of the JFIF-format JPEG's that I've seen begin with
  613.        ;; the following.  I have no idea if this is standard.
  614.        ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF"
  615.                  [jpeg :data nil] 2)))
  616.        ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2)))
  617.        ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2)))
  618.        ("" [autodetect :data nil] 2))))
  619.   ;; #### this should really be formatted-string, not string but we
  620.   ;; don't have it implemented yet
  621.   ;;
  622.   ;; #define could also mean a bitmap as well as a version 1 XPM.  Who
  623.   ;; cares.  We don't want the file contents getting converted to a
  624.   ;; string in either case which is why the entry is there.
  625.   (if (featurep 'tty)
  626.       (progn
  627.     (set-console-type-image-conversion-list
  628.      'tty
  629.      '(("^#define" [string :data "[xpm]"])
  630.        ("\\`X-Face:" [string :data "[xface]"])
  631.        ("\\`/\\* XPM \\*/" [string :data "[xpm]"])
  632.        ("\\`GIF87" [string :data "[gif]"])
  633.        ("\\`\377\330\340\000\020JFIF" [string :data "[jpeg]"])
  634.        ("" [string :data nil] 2)
  635.        ;; this last one is here for pointers and icons and such --
  636.        ;; strings are not allowed so they will be ignored.
  637.        ("" [nothing])))
  638.  
  639.     ;; finish initializing truncation glyph -- created internally
  640.     ;; because it has a built-in bitmap
  641.     (set-glyph-image truncation-glyph "$" 'global 'tty)
  642.  
  643.     ;; finish initializing continuation glyph -- created internally
  644.     ;; because it has a built-in bitmap
  645.     (set-glyph-image continuation-glyph "\\" 'global 'tty)
  646.  
  647.     ;; finish initializing hscroll glyph -- created internally
  648.     ;; because it has a built-in bitmap
  649.     (set-glyph-image hscroll-glyph "$" 'global 'tty)))
  650.  
  651.   (set-glyph-image octal-escape-glyph "\\")
  652.   (set-glyph-image control-arrow-glyph "^")
  653.   (set-glyph-image invisible-text-glyph " ...")
  654.   ;; (set-glyph-image hscroll-glyph "$")
  655.  
  656.   ;; finish initializing xemacs logo -- created internally because it
  657.   ;; has a built-in bitmap
  658.   (if (featurep 'xpm)
  659.       (set-glyph-image xemacs-logo
  660.                (concat "../etc/" "xemacs.xpm")
  661.                'global 'x))
  662.   (cond ((featurep 'xpm)
  663.      (set-glyph-image frame-icon-glyph
  664.               (concat "../etc/" "xemacs-icon.xpm")
  665.               'global 'x))
  666.     ((featurep 'x)
  667.      (set-glyph-image frame-icon-glyph
  668.               (concat "../etc/" "xemacs-icon2.xbm")
  669.               'global 'x)))
  670.  
  671.   (if (featurep 'tty)
  672.       (set-glyph-image xemacs-logo
  673.                "XEmacs <insert spiffy graphic logo here>"
  674.                'global 'tty))
  675. )
  676.  
  677. (init-glyphs)
  678.  
  679. ;;; glyphs.el ends here.
  680.